perm filename HOMER.F4[MSS,LCS]1 blob
sn#091408 filedate 1974-03-19 generic text, type T, neo UTF8
00100 C***** SUBR. HOMER, FUNC. FINDIT, PLACE, IABS ********
00200
00300 C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
00400 SUBROUTINE HOMER
00500 IMPLICIT INTEGER(A-Q,S-Z)
00600 REAL DIS,PWDS,DISX,A,B,PLACE
00700 COMMON /STF/RSTFAC(8),RSTJC
00800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20) /POSI/STFF(8),JJB,POS
00900 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
01000 EQUIVALENCE (RJC,RJQ(1)),(RJF,RJQ(4)),(JK,JQ(9)),(RD,RN(4000))
01100 1,(RJG,RJQ(5)),(RJI,RJQ(7)),(RJK,RJQ(9)),(RJM,RJQ(11))
01200 1,(JJ,JQ(8)),(RJH,RJQ(6))
01300 IF(JA.EQ.9)GO TO 9
01400 IF(RJM.NE.0)GO TO 10
01500 C FOR GENL HOMING; WORDS; BEAMS; STEMS;
01600
01700 C NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
01800 197 JJB=-1
01900 DO 191 K=1,ITEM
02000 L=PWDS(K)
02100 IF(RN(L+1).NE.9..OR.(RN(L+3).NE.RJB.AND.RJB.LT.5.))GO TO 191
02200 C TYPE 19 99 FOR ALL STAVES
02300 RG=RN(L+7)
02400 IF(RN(L).EQ.8..OR.RG.LT.10.)GO TO 191
02500 C FINDS BEAMS.
02600 A=RN(L+2)
02700 B=RN(L+6)
02800 C POS 1 AND 2
02900 DISX=B-A
03000 C DISTANCE IN REAL STEPS
03100 RB=AMOD(RN(L+5),100.0)
03200 C NOTE 2
03300 RF=AMOD(RN(L+4),100.0)
03400 RD=RB-RF
03500 C HEIGHT
03600 RJC=RN(L+3)
03700 X=RG/10.
03800 C STEM DIRECT.
03900
04000 DO 192 N=1,ITEM
04100 CC L=PWDS(N)
04200 IF(FINDIT(N))GO TO 192
04210 IF(RN(L).EQ.8)GO TO 192
04220 C SKIPS SLASHED GRACE NOTES
04300 C FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
04400 RC=RN(L+2)
04500 IF(RC.LT.A.OR.RC.GT.B)GO TO 192
04600 C WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
04700 IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
04800 RC=RC-A
04900 193 RE=AMOD(RN(L+4),100.0)
05000 RC=RD*RC/DISX+RF
05100 RG=RN(L+7)
05200 RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
05300 C DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
05400 C FRACTIONAL NOTE #
05500 195 RA=RC-RE
05600 IF(X.EQ.2)RA=-RA
05700 IF(RA.EQ.0)RA=999.
05800 196 RN(L+8)=RA
05900 C FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
06000 IF(JJB)JJB=N
06100 C SAVES # OF FIRST ITEM FOUND
06200 192 CONTINUE
06300 191 CONTINUE
06400 RETURN
06500
06600 9 IF(JK.LT.0)RETURN
06700 C IF P11=-1 NO HOMING
06800 X=RJG/10.
06900 C X IS STEM DIRECTION
07000 RA=RJI
07100 C RJI= POS3
07200 RC=-1.
07300 IF(RJI.NE.0)RC=-2.
07310 IF(JJ/100.EQ.3)RC=-3
07400 C RC=1 ESCAPES FROM LOOP.
07500 C HOMING RANGE FOR BEAMS
07600 10 IF(RJK.EQ.0)RJK=2.9
07700 C IF P11.NE.0 RANGE IS CHANGED FROM 2
07710 IF(JA.EQ.8)RC=-1
07800 CC RE=1.15
07900 CC A=0
08000 CC B=0
08100 DO 361 K=1,ITEM
08300 IF(FINDIT(K))GO TO 361
08400 C SKIPS NOTES ON WRONG LINE
08500 RD=RN(L+2)
08600 CC IF(JA.NE.8)GO TO 1
08700 CC RF=RE*RSTJC
08800 CC IF(RJM.LT.2)GO TO 2
08900 C IF P13=2 SLUR "HOMES" BETWEEN NOTES
09000 CC RE=3.4
09100 CC RF=-.9
09110 CC IF(RN(L+6))RE=3.7
09155 C FOR WHITE NOTES
09200 CC IF(RN(L+7).GE.10)RE=5.8
09250 C FOR DOTTED NOTES
09300 CC2 IF(A.NE.0.OR.PLACE(RJB))GO TO 3
09400 CC A=RD+RE*RSTJC
09500 C PLACES BOTH ENDS OF A SLUR
09600 CC RJB=A
09700 CC3 IF(B.NE.0.OR.PLACE(RJF))GO TO 4
09800 CC B=RD+RF
09900 CC RJF=B
10000 CC4 IF((A.EQ.0.OR.B.EQ.0).AND.K.LT.ITEM)GO TO 361
10100 CC RETURN
10200 1 IF(JA.EQ.9.AND.IFIX(RN(L+5)/10).NE.X)GO TO 361
10300 IF(PLACE(RJB))GO TO 461
10400 RJB=RD
10500 C LOOKS FOR NOTE, STAFF #, STEM DIR.
10600 IF(JA.EQ.9.OR.JA.EQ.8)GO TO 261
10700 RETURN
10800
10900 461 IF(JA.NE.9.AND.JA.NE.8)GO TO 361
11000 IF(PLACE(RJF))GO TO 561
11100 RJF=RD
11200 GO TO 261
11300 561 IF(PLACE(RA))GO TO 661
11400 RJI=RD
11410 GO TO 261
11420 661 IF(JA.EQ.8.OR.JJ.LT.300)GO TO 361
11430 IF(PLACE(RJH))GO TO 361
11435 C HOMES INNER PARTIAL BEAMS
11440 RJH=RD
11500 261 RC=RC+1
11600 IF(RC.EQ.1.)RETURN
11700 361 CONTINUE
11800 END
11900
12000 FUNCTION PLACE(X)
12100 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
12200 EQUIVALENCE (RJK,RJQ(9)),(RD,RN(4000))
12400 PLACE=RJK-ABS(RD-X)
12500 END
12600
12700 FUNCTION FINDIT(N)
12800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
12900 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
13000 FINDIT=0
13100 L=PWDS(N)
13200 IF(RN(L+1).NE.1.OR.RN(L+3).NE.RJQ(1))FINDIT=-1
13300 END
13400
13500 FUNCTION IABS(N)
13600 IABS=N
13700 IF(N)IABS=-N
13800 END
13900
14000 BLOCK DATA
14100 IMPLICIT INTEGER(A-Q,S-Z)
14200 COMMON /NW/FILL(7),RNOTE(24)
14300 COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
14400 DATA FILL/4,5,6,6,6,5,4/,
14500 1 RNOTE/ 1000., .002, 2.005, 6.007, 10.007, 14.005, 16.002,
14600 1 16.102, 14.105, 10.107, 6.107, 2.105, .102, 0, 4.005, 11.006,
14700 1 1016., 12.105, 5.106, 1000.,7.007,14., 7.107, 0/,
14800 1 NUMQ/1,11,15,23,33,38,47,57,62,79, 89,95,108,117,125,132,138
14900 1,150,157,164,171,177,181,187,1,192,200,212,221,234,239,246
15000 1,250,256,261,266, 271,282,285,293,298,307,316,321/
15100 DATA (RNUMS(K),K=1,131)/10.0,1003.107, 6.102, 6.01, 3.015,
15200 1 104.015, 107.01,107.102, 104.107, 3.107,
15300 1 14.0, 1103.011, 1.015, 1.107, 22.0,
15400 1 1106.011, 102.015, 3.015, 7.011, 7.005, 107.107, 7.107, 32.0,
15500 1 1107.015, 7.015, 101.007, 3.007, 7.003, 7.102, 3.107, 103.107,
15600 1 107.103, 37.0, 1007.102, 107.102, 2.015, 2.107, 46.0, 1107.107,
15700 1 4.103, 7.0, 7.004, 2.006, 107.004, 107.015, 7.015, 56.0,
15800 1 1004.015, 107.0, 107.103, 103.107, 4.107, 7.103, 7.0, 3.003,
15900 1 104.003, 61.0, 1107.011, 107.015, 7.015, 107.107, 78.0, 1003.004,
16000 1 7.0, 7.103, 4.107, 104.107, 107.103, 107.0, 103.004, 3.004,
16100 1 6.008, 6.012, 2.015, 102.015, 106.012, 106.008, 103.004,
16200 1 88.0, 1104.107, 7.008, 7.011, 4.015, 104.015, 107.011, 107.008,
16300 1 103.005, 4.005, 94.0, 1106.107, 0.015,6.107,1004.101,104.101,
16400 1 107.0, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 1106.004,
16500 1 2.004, 6.001, 6.104, 3.107, 106.107, 116.0, 1006.104, 3.107,
16600 1 103.107, 106.104, 106.011, 103.015, 3.015, 6.011, 124.0,
16700 1 1106.107, 106.015, 3.015, 6.011, 6.103, 3.107, 106.107,
16800 1 131.0, 1006.107, 106.107, 106.015, 6.015, 1003.005, 106.005/
16900 C THE NEXT IS FOR 'F' TO 'P'
17000 C 1 NUM NOT NEEDED IN 'G' ALSO IN RNOTE (1/2 NOTE).
17100 DATA (RNUMS(K),K=132,199)/
17200 1 137.0, 1106.107, 106.015, 6.015, 1003.005, 106.005, 149.0,
17300 1 1001.102, 6.102, 6.104, 6.104, 3.107, 103.107, 106.104,
17400 1 106.011, 103.015, 3.015, 6.011, 156.0, 1106.107, 106.015,
17500 1 1006.015, 6.107, 1006.005, 106.005, 163.0, 1103.107,3.107,
17600 1 1000.107, 0.015, 1103.015, 3.015,
17700 1 170.0, 1106.102, 106.104, 103.107, 3.107, 6.104, 6.015,
17800 1 176.0, 1106.107, 106.015, 1006.015, 106.005, 6.107, 180.0,
17900 1 1006.107, 106.107, 106.015, 186.0, 1106.107, 106.015, 0.004,
18000 1 6.015, 6.107, 191.0, 1106.107, 106.015, 6.107, 6.015, 199.0
18100 1, 1106.107, 106.015, 3.015, 6.012, 6.007, 3.004, 106.004/
18200 C 'Q' TO ')'
18300 DATA(RNUMS(K),K=200,327)/
18400 1 211.0, 1003.107, 6.102, 6.01, 3.015, 103.015, 106.01, 106.102,
18500 1 103.107, 3.107, 1001.001, 7.108, 220.0, 1106.107, 106.015,
18600 1 3.015, 6.012, 6.007, 3.004, 106.004, 6.107, 233.0, 1106.104,
18700 1 103.107, 3.107, 6.104, 6.001, 3.004, 103.004, 106.007, 106.011,
18800 1 103.015, 3.015, 6.01, 238.0, 1106.015, 7.015, 1000.015, 0.107,
18900 1 245.0, 1106.015, 106.104, 103.107, 3.107, 6.104, 6.015, 249.0,
19000 1 1106.015, 0.107, 6.015, 255.0, 1106.015, 104.107, 0.005, 4.107,
19100 1 6.015, 260.0, 1106.015, 6.107, 1106.107, 6.015, 265.0, 1106.015,
19200 1 0.003, 1106.107, 6.015, 270.0, 1106.015, 6.015, 106.107, 6.107,
19300 1 281.0, 1101.102, 101.105, 1.105, .102, .105, 101.102, 1.102,
19400 1 1.108, 102.112, 1102.112, 284., 1106.004, 6.004, 292., 1101.102,
19500 1 101.105, 0.102, 0.105, 1.102, 1.105, 101.102, 297.0, 1106.008,
19600 1 6.008, 1106.001, 6.001, 306.0, 1003.015, 1.013, 101.010,
19700 1 102.006,102.002,101.102,1.105, 3.107, 315.0, 1103.015,101.013,
19800 1 1.010, 2.006, 2.002, 1.102, 101.105, 103.107, 320.0, 1106.004,
19900 1 6.004, 1000.01, 0.102, 327.0,1106.004, 6.004, 1003.009,
20000 1 103.101, 1003.101, 103.009/
20050 C 3RD ITEM IN 19400 NOT NEEDED 12/73
20100
20200 C 1-10=NUMS 0-9, 11-36=ALPHA, 37-42=SIGNS
20300 DATA RACCI/8.0,1114.003,111.007, 108.007, 106.003, 107.101
20400 1,114.108, 114.02, 21.0,1104.105, 118.109, 118.108,104.104
20500 1,1108.113, 108.016, 1104.008, 118.004, 118.005,104.009
20600 1,1114.014, 114.115, 32.0,1106.117, 106.007, 114.004
20700 1,114.004, 106.007, 1114.018, 114.107, 106.104, 106.103
20800 1,114.106/,NACCI/1,9,22/
20900 END